(*
 * My favorite high-order procedure.
 *)
fun fold (lst, folder, state) =
	let fun loop (lst, state) =
			case lst of
			[] => state
			| first::rest => loop (rest, folder (first, state))
	in loop (lst, state)
	end;

fun naturalFold (limit, folder, state) =
	if limit < 0
	    then raise Domain
	    else let fun loop (i, state) =
			     if i = limit
				 then state
				 else loop (i+1, folder (i, state))
		 in loop (0, state)
		 end;

fun naturalAny (limit, ok) =
	if limit < 0
	    then raise Domain
	    else let fun loop i =
			     i <> limit andalso
				 (ok i orelse loop (i+1))
		 in loop 0
		 end;

fun naturalAll (limit, ok) =
	if limit < 0
	    then raise Domain
	    else let fun loop i =
			     i = limit orelse
				 (ok i andalso loop (i+1))
		 in loop 0
		 end;
(*
 * Fold over all permutations.
 * Universe is a list of all the items to be permuted.
 * pFolder is used to build up the permutation.  It is called via
 *	pFolder (next, pState, state, accross)
 * where next is the next item in the permutation, pState is the
 * partially constructed permutation and state is the current fold
 * state over permutations that have already been considered.
 * If pFolder knows what will result from folding over all permutations
 * descending from the resulting partial permutation (starting at state),
 * it should raise the accross exception carrying the new state value.
 * If pFolder wants to continue building up the permutation, it should
 * return (newPState, newState).
 * When a permutation has been completely constructed, folder is called
 * via
 *	folder (pState, state)
 * where pState is the final pState and state is the current state.
 * It should return the new state.
 *)
fun 'a foldOverPermutations (universe, pFolder, pState, folder, state: 'a) =
	let exception accross of 'a
	    fun outer (universe, pState, state) =
		    case universe of
		    [] => folder (pState, state)
		    | first::rest =>
			let fun inner (first, rest, revOut, state) =
				    let val state =
						let val (newPState, state) =
							    pFolder (first,
								     pState,
								     state,
								     accross)
						in outer (fold (revOut,
								op ::,
								rest),
							  newPState,
							  state)
						end handle accross state => state
				    in case rest of
				       [] => state
				       | second::rest =>
					   inner (second,
						  rest,
						  first::revOut,
						  state)
				    end
			in inner (first, rest, [], state)
			end
	in outer (universe, pState, state)
	end;
(*
 * Fold over all arrangements of bag elements.
 * Universe is a list of lists of items, with equivalent items in the
 * same list.
 * pFolder is used to build up the permutation.  It is called via
 *	pFolder (next, pState, state, accross)
 * where next is the next item in the permutation, pState is the
 * partially constructed permutation and state is the current fold
 * state over permutations that have already been considered.
 * If pFolder knows what will result from folding over all permutations
 * descending from the resulting partial permutation (starting at state),
 * it should raise the accross exception carrying the new state value.
 * If pFolder wants to continue building up the permutation, it should
 * return (newPState, newState).
 * When a permutation has been completely constructed, folder is called
 * via
 *	folder (pState, state)
 * where pState is the final pState and state is the current state.
 * It should return the new state.
 *)
fun 'a foldOverBagPerms (universe, pFolder, pState, folder, state: 'a) =
	let exception accross of 'a
	    fun outer (universe, pState, state) =
		    case universe of
		    [] => folder (pState, state)
		    | (fbag as (first::fclone))::rest =>
			let fun inner (fbag, first, fclone, rest, revOut, state) =
				    let val state =
						let val (newPState, state) =
							    pFolder (first,
								     pState,
								     state,
								     accross)
						in outer (fold (revOut,
								op ::,
								case fclone of
								[] => rest
								| _ => fclone::rest),
							  newPState,
							  state)
						end handle accross state => state
				    in case rest of
				       [] => state
				       | (sbag as (second::sclone))::rest =>
					   inner (sbag,
						  second,
						  sclone,
						  rest,
						  fbag::revOut,
						  state)
				    end
			in inner (fbag, first, fclone, rest, [], state)
			end
	in outer (universe, pState, state)
	end;
(*
 * Fold over the tree of subsets of the elements of universe.
 * The tree structure comes from the root picking if the first element
 * is in the subset, etc.
 * eFolder is called to build up the subset given a decision on wether
 * or not a given element is in it or not.  It is called via
 *	eFolder (elem, isinc, eState, state, fini)
 * If this determines the result of folding over all the subsets consistant
 * with the choice so far, then eFolder should raise the exception
 *	fini newState
 * If we need to proceed deeper in the tree, then eFolder should return
 * the tuple
 *	(newEState, newState)
 * folder is called to buld up the final state, folding over subsets
 * (represented as the terminal eStates).  It is called via
 *	folder (eState, state)
 * It returns the new state.
 * Note, the order in which elements are folded (via eFolder) is the same
 * as the order in universe.
 *)
fun 'a foldOverSubsets (universe, eFolder, eState, folder, state: 'a) =
	let exception fini of 'a
	    fun f (first, rest, eState) (isinc, state) =
		    let val (newEState, newState) =
				eFolder (first,
					 isinc,
					 eState,
					 state,
					 fini)
		    in outer (rest, newEState, newState)
		    end handle fini state => state
	    and outer (universe, eState, state) =
			case universe of
			[] => folder (eState, state)
			| first::rest =>
			    let val f = f (first, rest, eState)
			    in f (false, f (true, state))
			    end
	    in outer (universe, eState, state)
	    end;

fun f universe =
	foldOverSubsets (universe,
			 fn (elem, isinc, set, state, _) =>
			     (if isinc
				  then elem::set
				  else set,
			      state),
			 [],
			 fn (set, sets) => set::sets,
			 []);
(*
 * Given a partitioning of [0, size) into equivalence classes (as a list
 * of the classes, where each class is a list of integers), and where two
 * vertices are equivalent iff transposing the two is an automorphism
 * of the full subgraph on the vertices [0, size), return the equivalence
 * classes for the graph.  The graph is provided as a connection function.
 * In the result, two equivalent vertices in [0, size) remain equivalent
 * iff they are either both connected or neither is connected to size.
 * The vertex size is equivalent to a vertex x in [0, size) iff
 *	connected (size, y) = connected (x, if y = x then size else y)
 * for all y in [0, size).
 *)
fun refine (size: int,
	    classes: int list list,
	    connected: int*int -> bool): int list list =
	let fun sizeMatch x =
		(* Check if vertex size is equivalent to vertex x. *)
		    naturalAll (size,
				fn y => connected (size, y) =
					    connected (x,
						       if y = x
							   then size
							   else y))
	    fun merge (class, (merged, classes)) =
		(* Add class into classes, testing if size should be merged. *)
		    if merged
			then (true, (rev class)::classes)
			else let val first::_ = class
			     in if sizeMatch first
				    then (true, fold (class,
						      op ::,
						      [size])::classes)
				    else (false, (rev class)::classes)
			     end
	    fun split (elem, (yes, no)) =
		    if connected (elem, size)
			then (elem::yes, no)
			else (yes, elem::no)
	    fun subdivide (class, state) =
		    case class of
		    [first] => merge (class, state)
		    | _ => case fold (class, split, ([], [])) of
			   ([], no) => merge (no, state)
			   | (yes, []) => merge (yes, state)
			   | (yes, no) => merge (no, merge (yes, state))
	in case fold (classes, subdivide, (false, [])) of
	   (true, classes) => rev classes
	   | (false, classes) => fold (classes, op ::, [[size]])
	end;
(*
 * Given a count of the number of vertices, a partitioning of the vertices
 * into equivalence classes (where two vertices are equivalent iff
 * transposing them is a graph automorphism), and a function which, given
 * two distinct vertices, returns a bool indicating if there is an edge
 * connecting them, check if the graph is minimal.
 * If it is, return
 *	SOME how-many-clones-we-walked-through
 * If not, return NONE.
 * A graph is minimal iff its connection matrix is (weakly) smaller
 * then all its permuted friends, where true is less than false, and
 * the entries are compared lexicographically in the following order:
 *	-
 *	0 -
 *	1 2 -
 *	3 4 5 -
 *	...
 * Note, the vertices are the integers in [0, nverts).
 *)
fun minimal (nverts: int,
	     classes: int list list,
	     connected: int*int -> bool): int option =
	let val perm = Array.array (nverts, ~1)
	    exception fini
	    fun pFolder (new, old, state, accross) =
		    let fun loop v =
				if v = old
				    then (Array.update (perm, old, new);
					  (old + 1, state))
				    else case (connected (old,
							  v),
					       connected (new,
							  Array.sub (perm,
								     v))) of
					 (true, false) =>
					     raise (accross state)
					 | (false, true) =>
					     raise fini
					 | _ =>
					     loop (v + 1)
		    in loop 0
		    end
	    fun folder (_, state) =
		    state + 1
	in SOME (foldOverBagPerms (
		     classes,
		     pFolder,
		     0,
		     folder,
		     0)) handle fini => NONE
	end;
(*
 * Fold over the tree of graphs.
 *
 * eFolder is used to fold over the choice of edges via
 *	eFolder (from, to, isinc, eState, state, accross)
 * with from > to.
 *
 * If eFolder knows the result of folding over all graphs which agree
 * with the currently made decisions, then it should raise the accross
 * exception carrying the resulting state as a value.
 *
 * To continue normally, it should return the tuple
 *	(newEState, newState)
 *
 * When all decisions are made with regards to edges from `from', folder
 * is called via
 *	folder (size, eState, state, accross)
 * where size is the number of vertices in the graph (the last from+1) and
 * eState is the final eState for edges from `from'.
 *
 * If folder knows the result of folding over all extensions of this graph,
 * it should raise accross carrying the resulting state as a value.
 *
 * If extensions of this graph should be folded over, it should return
 * the new state.
 *)
fun ('a, 'b) foldOverGraphs (eFolder, eState: 'a, folder, state: 'b) =
	let exception noextend of 'b
	    fun makeVertss limit =
		    Vector.tabulate (limit,
				     fn nverts =>
					     List.tabulate (nverts,
							    fn v => v))
	    val vertss = ref (makeVertss 0)
	    fun findVerts size = (
		    if size >= Vector.length (!vertss)
			then vertss := makeVertss (size + 1)
			else ();
		    Vector.sub (!vertss, size))
	    fun f (size, eState, state) =
		    let val state =
				folder (size, eState, state, noextend)
		    in g (size+1, state)
		    end handle noextend state => state
	    and g (size, state) =
		    let val indices =
				findVerts (size - 1)
			fun SeFolder (to, isinc, eState, state, accross) =
				eFolder (size-1,
					 to,
					 isinc,
					 eState,
					 state,
					 accross)
			fun Sf (eState, state) =
				f (size, eState, state)
		    in foldOverSubsets (
			indices,
			SeFolder,
			eState,
			Sf,
			state)
		    end
	in f (0, eState, state)
	end;

(*
 * Given the size of a graph, a list of the vertices (the integers in
 * [0, size)), and the connected function, check if for all full subgraphs,
 *	3*V - 4 - 2*E >= 0 or V <= 1
 * where V is the number of vertices and E is the number of edges.
 *)
local fun short lst =
	case lst of
	[] => true
	| [_] => true
	| _ => false;
in fun okSoFar (size, verts, connected) =
	let exception fini of unit
	    fun eFolder (elem, isinc, eState as (ac, picked), _, accross) =
		    (if isinc
			 then (fold (picked,
				     fn (p, ac) =>
					 if connected (elem, p)
					     then ac - 2
					     else ac,
				     ac + 3),
			       elem::picked)
			 else eState,
		     ())
	    fun folder ((ac, picked), state) =
		    if ac >= 0 orelse short picked
			then state
			else raise (fini ())
	in (foldOverSubsets (
	       verts,
	       eFolder,
	       (~4, []),
	       folder,
	       ());
	    true) handle fini () => false
	end
end;

fun showGraph (size, connected) =
	naturalFold (size,
		     fn (from, _) => (
			 print ((Int.toString from) ^ ":");
			 naturalFold (size,
				      fn (to, _) =>
					  if from <> to andalso connected (from, to)
					      then print (" " ^ (Int.toString to))
					      else (),
				      ());
			 print "\n"),
		     ());

fun showList (start, sep, stop, trans) lst = (
	start ();
	case lst of
	[] => ()
	| first::rest => (
	    trans first;
	    fold (rest,
		  fn (item, _) => (
		      sep ();
		      trans item),
		  ()));
	stop ());

val showIntList = showList (
		      fn () => print "[",
		      fn () => print ", ",
		      fn () => print "]",
		      fn i => print (Int.toString i));

val showIntListList = showList (
		      fn () => print "[",
		      fn () => print ", ",
		      fn () => print "]",
		      showIntList);

fun h (maxSize, folder, state) =
	let val ctab = Array.tabulate (maxSize,
				       fn v => Array.array (v, false))
	    val classesv = Array.array (maxSize+1, [])
	    fun connected (from, to) =
		let val (from, to) = if from > to
					 then (from, to)
					 else (to, from)
		in Array.sub (Array.sub (ctab, from), to)
		end
	    fun update (from, to, value) =
		let val (from, to) = if from > to
					 then (from, to)
					 else (to, from)
		in Array.update (Array.sub (ctab, from), to, value)
		end
	    fun triangle (vnum, e) =
		naturalAny (e,
			    fn f => connected (vnum, f)
					andalso connected (e, f))
	    fun eFolder (from, to, isinc, _, state, accross) =
		    if isinc andalso triangle (from, to)
			then raise (accross state)
			else (
			    update (from, to, isinc);
			    ((), state))
	    fun Gfolder (size, _, state, accross) = (
		    if size <> 0
			then Array.update (classesv,
					   size,
					   refine (size-1,
						   Array.sub (classesv,
							      size-1),
					   connected))
			else ();
		    case minimal (size, Array.sub (classesv, size), connected) of
		    NONE => raise (accross state)
		    | SOME eatMe =>
			if okSoFar (size,
				    List.tabulate (size, fn v => v),
				    connected)
			    then let val state =
					 folder (size, connected, state)
				 in if size = maxSize
					then raise (accross state)
					else state
				 end
			    else raise (accross state))
	in foldOverGraphs (eFolder,
			   (),
			   Gfolder,
			   state)
	end;

local fun final (size: int, connected: int * int -> bool): int =
	naturalFold (size,
		     fn (from, ac) =>
			 naturalFold (from,
				      fn (to, ac) =>
					  if connected (from, to)
					      then ac - 2
					      else ac,
				      ac),
		     3*size - 4)
in fun f maxSize =
	h (maxSize,
	   fn (size, connected, state) =>
		   if final (size, connected) = 0
		       then state + 1
		       else state,
	   0)
end;

fun doOne arg = (
	print (arg ^ " -> ");
	case Int.fromString arg of
	SOME n =>
		print ((Int.toString (f n)) ^ "\n")
	| NONE =>
		print "NOT A NUMBER\n");

   structure Main =
      struct
	 fun doit() =
	    List.app doOne ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

	 val doit =
	    fn () =>
	    let
	       fun loop n =
		  if n = 0
		     then ()
		  else (doit();
			loop(n-1))
	    in loop 3
	    end
      end;

